home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctj8502.arc / DATETIME.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-14  |  2KB  |  87 lines
  1. { Turbo Pascal routines to read and set date and time }
  2. { Copyright 1984 Michael A. Covington }
  3.  
  4. { Each routine requires the following type definitions }
  5. { but does not require the other routines.             }
  6.  
  7. type datetimetype = string[8];
  8.      regtype      = record
  9.                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  10.                     end;
  11.  
  12. function date: datetimetype;
  13.   { Returns current date in form '08/31/84'. }
  14. var  reg:     regtype;
  15.      y,m,d,w: datetimetype;
  16.      i:       integer;
  17. begin
  18.   reg.ax:=$2A00;
  19.   intr($21,reg);
  20.   str(reg.cx:4,y);
  21.   delete(y,1,2);
  22.   str(hi(reg.dx):2,m);
  23.   str(lo(reg.dx):2,d);
  24.   w := m + '/' + d + '/' + y;
  25.   for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  26.   date:=w
  27. end;
  28.  
  29. function time: datetimetype;
  30.   { Returns current time in form '08:13:59'. }
  31. var  reg:     regtype;
  32.      h,m,s,w: datetimetype;
  33.      i:       integer;
  34. begin
  35.   reg.ax:=$2C00;
  36.   intr($21,reg);
  37.   str(hi(reg.cx):2,h);
  38.   str(lo(reg.cx):2,m);
  39.   str(hi(reg.dx):2,s);
  40.   w := h + ':' + m + ':' + s;
  41.   for i:=1 to length(w) do if w[i]=' ' then w[i]:='0';
  42.   time:=w
  43. end;
  44.  
  45. procedure setdate(x:datetimetype);
  46.   { Sets date.  Accepts string in format '08/31/84'. }
  47. var  reg:            regtype;
  48.      rh,rl,c1,c2,c3: integer;
  49. begin
  50.   reg.ax:=$2B00;
  51.   val(x[1]+x[2],rh,c1);  { month goes in DH }
  52.   val(x[4]+x[5],rl,c2);  { day goes in DL   }
  53.   reg.dx:=rh*256 + rl;
  54.   val(x[7]+x[8],rl,c3);  { year goes in CX  }
  55.   reg.cx:=rl + 1900;
  56.   if rl<80 then reg.cx:=reg.cx+100;  { 21st century }
  57.   c1:=c1+c2+c3;          { return codes from VAL }
  58.   if c1=0 then intr($21,reg);
  59.   if c1+lo(reg.ax) <> 0 then
  60.     begin
  61.       writeln;
  62.       writeln('Error--Invalid date, ''',x,'''');
  63.       halt
  64.     end
  65. end;
  66.  
  67. procedure settime(x:datetimetype);
  68.   { Sets time.  Accepts string in format '08:13:59'. }
  69. var  reg:            regtype;
  70.      rh,rl,c1,c2,c3: integer;
  71. begin
  72.   reg.ax:=$2D00;
  73.   val(x[1]+x[2],rh,c1);    { Hours go in CH   }
  74.   val(x[4]+x[5],rl,c2);    { Minutes go in CL }
  75.   reg.cx:=rh*256 + rl;
  76.   val(x[7]+x[8],rh,c3);    { Seconds go in DH }
  77.   reg.dx:=rh*256;
  78.   c1:=c1+c2+c3;            { Return codes from VAL }
  79.   if c1=0 then intr($21,reg);
  80.   if c1+lo(reg.ax) <> 0 then
  81.     begin
  82.       writeln;
  83.       writeln('Error--Invalid time, ''',x,'''');
  84.       halt
  85.     end
  86. end;
  87.